home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 1999 August / SGI Freeware 1999 August.iso / dist / fw_Tix.idb / usr / freeware / lib / tix4.1 / Tix.tcl.z / Tix.tcl
Encoding:
Text File  |  1999-01-26  |  11.8 KB  |  507 lines
  1. # Tix.tcl --
  2. #
  3. #    This file implements the Tix application context class
  4. #
  5. # Copyright (c) 1996, Expert Interface Technologies
  6. #
  7. # See the file "license.terms" for information on usage and redistribution
  8. # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  9. #
  10.  
  11. if 0 {
  12. proc tix {} {
  13.     # dummy proc. make sure the entry "tix" is in the tclIndex file
  14.     #
  15. }
  16. }
  17.  
  18. tixClass tixAppContext {
  19.     -superclass {}
  20.     -classname  TixAppContext
  21.     -method {
  22.     cget configure addbitmapdir filedialog getbitmap getimage
  23.     option platform resetoptions setbitmap
  24.     }
  25.     -flag {
  26.     -binding -debug -extracmdargs -filedialog -fontset -grabmode
  27.     -haspixmap -libdir -scheme -schemepriority -percentsubst
  28.     }
  29.     -readonly {
  30.     -haspixmap
  31.     }
  32.     -configspec {
  33.     {-binding            TK}
  34.     {-debug              false}
  35.     {-extracmdargs         1}
  36.     {-filedialog        ""}
  37.     {-fontset            TK}
  38.     {-grabmode         global}
  39.     {-haspixmap         0}
  40.     {-libdir             ""}
  41.     {-percentsubst        0}
  42.     {-scheme             TK}
  43.     {-schemepriority         21}
  44.     }
  45.     -alias {
  46.     }
  47. }
  48.  
  49. proc tixAppContext:Constructor {w} {
  50.     upvar #0 $w data
  51.     global tix_priv env argv0 tixPriv
  52.     global tix_library tixOption tcl_platform
  53.  
  54.     if {[info exists tcl_platform] && $tcl_platform(platform) == "windows"} {
  55.     regsub -all "/" $tix_library \\ tix_library
  56.     }
  57.  
  58.     if [info exists data(initialized)] {
  59.     error "tixAppContext has already be initialized"
  60.     } else {
  61.     set data(initialized) 1
  62.     }
  63.  
  64.     if [tixStrEq $tix_library ""] {
  65.     set data(et) 1
  66.     } else {
  67.     set data(et) 0
  68.     }
  69.  
  70.     set data(isStartUp) 1
  71.     # Thses options were set when tixwish started up
  72.     #
  73.     set data(-binding)        $tix_priv(-binding)
  74.     set data(-debug)        $tix_priv(-debug)
  75.     set data(-fontset)        $tix_priv(-fontset)
  76.     set data(-scheme)        $tix_priv(-scheme)
  77.     set data(-schemepriority)    $tix_priv(-schemepriority)
  78.  
  79.     if ![info exists tix_priv(isSafe)] {
  80.     set data(-libdir)    [tixFSAbsPath $tix_library]
  81.     }
  82.     set tixOption(prioLevel) $tix_priv(-schemepriority)
  83.  
  84.     # Enable/Disable Intrinsics debugging
  85.     #
  86.     if {$data(-debug)} {
  87.     set tix_priv(debug) 1
  88.     } else {
  89.     set tix_priv(debug) 0
  90.     }
  91.  
  92.     if ![info exists tix_priv(isSafe)] {
  93.     tixAppContext:config-fontset $w $data(-fontset)
  94.     tixAppContext:config-scheme  $w $data(-scheme)
  95.     }
  96.  
  97.     tixAppContext:BitmapInit $w
  98.     tixAppContext:FileDialogInit $w
  99.  
  100.     # Force the "." window to accept the new Tix options
  101.     #
  102.     foreach spec [. configure] {
  103.     if {[llength $spec] > 2} {
  104.         set flag  [lindex $spec 0]
  105.         set name  [lindex $spec 1]
  106.         set class [lindex $spec 2]
  107.         set value [option get . $name $class]
  108.         catch {. config $flag $value}
  109.     }
  110.     }
  111.     # Clean up any error message generated by the above loop
  112.     catch {uplevel #0 set errorInfo \"\"}
  113.  
  114.     set data(isStartUp) 0
  115.  
  116.     # Hack: if env(TIX_DEBUG_INTERACTIVE) is set, then
  117.     # an interactive prompt is always printed
  118.     #
  119.     if {[info exists env(TIX_DEBUG_INTERACTIVE)] &&
  120.     ![info exists tix_priv(slaveInterp)]} {
  121.  
  122.     # For widget programming, it is more convient to have the error
  123.     # message printed on the terminal. For some extensive usage of
  124.     # bindings, suce as in the case of tixBalloon, the default
  125.     # therror just doesn't work.
  126.     #
  127.     proc tkerror {err} {
  128.         global errorInfo
  129.         puts $err
  130.         puts $errorInfo
  131.     }
  132.     }
  133.  
  134.     #
  135.     # Hack
  136.     #
  137.     if [info exists env(TIX_DEBUG_GEOMETRY)] {
  138.     global tcl_interactive
  139.     if {$tcl_interactive == 0} {
  140.         wm geometry . $env(TIX_DEBUG_GEOMETRY)
  141.     }
  142.     }
  143. }
  144.  
  145. #----------------------------------------------------------------------
  146. #  Configurations
  147. #
  148. #----------------------------------------------------------------------
  149. proc tixAppContext:resetoptions {w scheme fontset {schemePrio ""}} {
  150.     upvar #0 $w data
  151.  
  152.     if {! $data(et)} {
  153.     global tixOption
  154.     option clear
  155.  
  156.     if {$schemePrio != ""} {
  157.         set tixOption(prioLevel) $schemePrio
  158.     }
  159.     tixAppContext:config-scheme  $w $scheme
  160.     tixAppContext:config-fontset $w $fontset
  161.     }
  162. }
  163.  
  164. proc tixAppContext:config-fontset {w value} {
  165.     upvar #0 $w data
  166.     global tix_priv tixOption
  167.  
  168.     set data(-fontset) $value
  169.  
  170.     #-----------------------------------
  171.     # Initialization of options database
  172.     #-----------------------------------
  173.     # Load the fontset
  174.     #
  175.     if {!$data(et)} {
  176.         set prefDir [tixFileJoin $data(-libdir) pref]
  177.         set fontSetFile [tixFileJoin $prefDir $data(-fontset).fsc]
  178.     if [file exists $fontSetFile] {
  179.         source $fontSetFile
  180.         tixPref:InitFontSet:$data(-fontset)
  181.         tixAppContext:CheckFontSets $w
  182.         tixPref:SetFontSet:$data(-fontset)
  183.     } else {
  184.         tixAppContext:StartupError \
  185.         "\aError: cannot use fontset \"$data(-fontset)\""
  186.         tixAppContext:StartupError \
  187.         "       Using default fontset "
  188.         tixSetDefaultFontset
  189.         tixAppContext:CheckFontSets $w
  190.     }
  191.     } else {
  192.     if [catch {
  193.         tixPref:InitFontSet:$data(-fontset)
  194.         tixAppContext:CheckFontSets $w
  195.         tixPref:SetFontSet:$data(-fontset)
  196.     }] {
  197.         # User chose non-existent fontset
  198.         #
  199.         tixAppContext:StartupError \
  200.         "\aError: cannot use fontset \"$data(-fontset)\""
  201.         tixAppContext:StartupError \
  202.         "       Using default fontset "
  203.         tixSetDefaultFontset
  204.         tixAppContext:CheckFontSets $w
  205.     }
  206.     }
  207.  
  208.     # Compatibility stuff: the obsolete name courier_font has been changed to
  209.     # fixed_font
  210.     set tixOption(courier_font) $tixOption(fixed_font)
  211. }
  212.  
  213. proc tixAppContext:config-scheme {w value} {
  214.     upvar #0 $w data
  215.     global tix_priv
  216.  
  217.     set data(-scheme) $value
  218.  
  219.     # Load the color scheme
  220.     #
  221.     if {!$data(et)} {
  222.     set schemeName [tixFileJoin [tixFileJoin $data(-libdir) pref] \
  223.         $data(-scheme).csc]
  224.     if [file exists $schemeName] {
  225.         source $schemeName
  226.         if {[winfo depth .] >= 8} {
  227.         tixPref:SetScheme-Color:$data(-scheme)
  228.         } else {
  229.         tixPref:SetScheme-Mono:$data(-scheme)
  230.         }
  231.     } else {
  232.         tixAppContext:StartupError \
  233.         "\aError: cannot use color scheme \"$data(-scheme)\""
  234.         tixAppContext:StartupError \
  235.         "       Using default color scheme"
  236.         if {[winfo depth .] >= 8} {
  237.         tixSetDefaultScheme-Color
  238.         } else {
  239.         tixSetDefaultScheme-Mono
  240.         }
  241.     }
  242.     } else {
  243.     if [catch {
  244.         if {[winfo depth .] >= 8} {
  245.         tixPref:SetScheme-Color:$data(-scheme)
  246.         } else {
  247.         tixPref:SetScheme-Mono:$data(-scheme)
  248.         }
  249.     }] {
  250.         # User chose non-existent color scheme
  251.         #
  252.         tixAppContext:StartupError \
  253.         "\aError: cannot use color scheme \"$data(-scheme)\""
  254.         tixAppContext:StartupError \
  255.         "       Using default color scheme"
  256.         if {[winfo depth .] >= 8} {
  257.         tixSetDefaultScheme-Color
  258.         } else {
  259.         tixSetDefaultScheme-Mono
  260.         }
  261.     }
  262.     }
  263. }
  264.  
  265. #----------------------------------------------------------------------
  266. #  Private methods
  267. #
  268. #----------------------------------------------------------------------
  269. proc tixAppContext:BitmapInit {w} {
  270.     upvar #0 $w data
  271.  
  272.     # See whether we have pixmap extension
  273.     #
  274.     set data(-haspixmap) true
  275.  
  276.     # Dynamically set the bitmap directory
  277.     #
  278.     if {! $data(et)} {
  279.     set data(bitmapdirs) [list [tixFileJoin $data(-libdir) bitmaps]]
  280.     } else {
  281.     set data(bitmapdirs) ""
  282.     }
  283. }
  284.  
  285. proc tixAppContext:FileDialogInit {w} {
  286.     upvar #0 $w data
  287.  
  288.     if {$data(-filedialog) == ""} {
  289.     set data(-filedialog) [option get . fileDialog FileDialog]
  290.     }
  291.     if {$data(-filedialog) == ""} {
  292.     set data(-filedialog) tixFileSelectDialog
  293.     }
  294. }
  295.  
  296. #----------------------------------------------------------------------
  297. # If a font in the fontset is not available, use a default fontset.
  298. #
  299. proc tixAppContext:CheckFontSets  {w} {
  300.     upvar #0 $w data
  301.     global tixOption tcl_platform tcl_version
  302.  
  303.     if {$tcl_version >= "8.0" && $tcl_platform(platform) == "windows"} {
  304.     # fonts will never fail ..
  305.     return
  306.     }
  307.  
  308.     set default_font "fixed"
  309.     set options {font bold_font menu_font italic_font fixed_font}
  310.  
  311.     if [winfo exists .tix-xxx-test] {
  312.     destroy .tix-xxx-test
  313.     }
  314.     set lab [label .tix-xxx-test]
  315.     foreach opt $options {
  316.     if [catch {$lab config -font $tixOption($opt)}] {
  317.         tixAppContext:StartupError \
  318.         "\aError: cannot use font \"$tixOption($opt)\" as \"$opt\""
  319.         puts  stderr \
  320.         "       using \"$default_font\" instead"
  321.  
  322.         set tixOption($opt) $default_font
  323.     }
  324.     }
  325.     destroy $lab
  326. }
  327.  
  328. #----------------------------------------------------------------------
  329. #     Public methods
  330. #----------------------------------------------------------------------
  331. proc tixAppContext:addbitmapdir {w bmpdir} {
  332.     upvar #0 $w data
  333.  
  334.     if {[lsearch $data(bitmapdirs) $bmpdir] == "-1"} {
  335.     lappend data(bitmapdirs) $bmpdir 
  336.     }
  337. }
  338.  
  339. proc tixAppContext:getimage {w name} {
  340.     upvar #0 $w data
  341.     global tixPriv tix_priv
  342.  
  343.     if {[info exists data(img:$name)]} {
  344.     return $data(img:$name)
  345.     }
  346.  
  347.     if ![info exists tix_priv(isSafe)] {
  348.     foreach dir $data(bitmapdirs) {
  349.         if [file exists [tixFileJoin $dir $name.xpm]] {
  350.         if {![catch {
  351.             set data(img:$name) \
  352.             [image create pixmap -file [tixFileJoin $dir $name.xpm]]
  353.         }]} {
  354.             break
  355.         }
  356.         }
  357.         if [file exists [tixFileJoin $dir $name.gif]] {
  358.         global TRANSPARENT_GIF_COLOR
  359.         if {![catch {
  360.             set data(img:$name) \
  361.             [image create photo -file [tixFileJoin $dir $name.gif]]
  362.         }]} {
  363.             break
  364.         }
  365.         }
  366.         if [file exists [tixFileJoin $dir $name.ppm]] {
  367.         if {![catch {
  368.             set data(img:$name) \
  369.             [image create photo -file [tixFileJoin $dir $name.ppm]]
  370.         }]} {
  371.             break
  372.         }
  373.         }
  374.         if [file exists [tixFileJoin $dir $name.xbm]] {
  375.         if {![catch {
  376.             set data(img:$name) \
  377.             [image create bitmap -file [tixFileJoin $dir $name.xbm]]
  378.         }]} {
  379.             break
  380.         }
  381.         }
  382.         if [file exists [tixFileJoin $dir $name]] {
  383.         if {![catch {
  384.             set data(img:$name) \
  385.             [image create bitmap -file [tixFileJoin $dir $name]]
  386.         }]} {
  387.             break
  388.         }
  389.         }
  390.     }
  391.     }
  392.  
  393.     if {![info exists data(img:$name)]} {
  394.     catch {
  395.         # This is for compiled-in images
  396.         set data(img:$name) [image create pixmap -id $name]
  397.     } err
  398.     if [string match internal* $err] {
  399.         error $err
  400.     }
  401.     }
  402.  
  403.     if {[info exists data(img:$name)]} {
  404.     return $data(img:$name)
  405.     } else {
  406.     error "image file \"$name\" cannot be found"
  407.     }
  408. }
  409.  
  410.  
  411. proc tixAppContext:getbitmap {w bitmapname} {
  412.     upvar #0 $w data
  413.     global tix_priv
  414.  
  415.     if {[info exists data(bmp:$bitmapname)]} {
  416.     return $data(bmp:$bitmapname)
  417.     } else {
  418.     set ext [file extension $bitmapname]
  419.     if {$ext == ""} {
  420.         set ext .xbm
  421.     }
  422.  
  423.     # This is the fallback value. If we can't find the bitmap in
  424.     # the bitmap directories, then use the name of the bitmap
  425.     # as the default value.
  426.     #
  427.     set data(bmp:$bitmapname) $bitmapname
  428.  
  429.     if [info exists tix_priv(isSafe)] {
  430.         return $data(bmp:$bitmapname)
  431.     }
  432.  
  433.     foreach dir $data(bitmapdirs) {
  434.         case $ext {
  435.         .xbm {
  436.             if [file exists [tixFileJoin $dir $bitmapname.xbm]] {
  437.             set data(bmp:$bitmapname) \
  438.                 @[tixFileJoin $dir $bitmapname.xbm]
  439.             break
  440.             }
  441.             if [file exists [tixFileJoin $dir $bitmapname]] {
  442.             set data(bmp:$bitmapname) @[tixFileJoin $dir $bitmapname]
  443.             break
  444.             }
  445.         }
  446.         default {
  447.             if [file exists [tixFileJoin $dir $bitmapname]] {
  448.             set data(bmp:$bitmapname) @[tixFileJoin $dir $bitmapname]
  449.             break
  450.             }
  451.         }
  452.         }
  453.     }
  454.  
  455.     return $data(bmp:$bitmapname)
  456.     }
  457. }
  458.  
  459. proc tixAppContext:filedialog {w {type tixFileSelectDialog}} {
  460.     upvar #0 $w data
  461.  
  462.     if {$type == ""} {
  463.     set type $data(-filedialog)
  464.     }
  465.     if {![info exists data(filedialog,$type)]} {
  466.     set data(filedialog,$type) ""
  467.     }
  468.  
  469.     if {$data(filedialog,$type) == "" || ![winfo exists $data(filedialog,$type)]} {
  470.     set data(filedialog,$type) [$type .tixapp_filedialog_$type]
  471.     }
  472.  
  473.     return $data(filedialog,$type)
  474. }
  475.  
  476. proc tixAppContext:option {w action option {value ""}} {
  477.     upvar #0 $w data
  478.     global tixOption
  479.  
  480.     if {$action == "get"} {
  481.     return $tixOption($option)
  482.     }
  483. }
  484.  
  485. proc tixAppContext:platform {w} {
  486.     upvar #0 $w data
  487.     global tixPriv
  488.  
  489.     if [info exists tixPriv(isWindows)] {
  490.     return windows
  491.     } else {
  492.     return unix
  493.     }
  494. }
  495.  
  496. proc tixAppContext:StartupError {msg} {
  497.     catch {
  498.     puts stderr $msg
  499.     }
  500. }
  501.  
  502. if [tixStrEq [info command toplevel] ""] {
  503.     proc toplevel {args} {
  504.     return eval frame $args
  505.     }
  506. }
  507.